;;; $Id: wfc.sld 405 2014-03-06 04:33:08Z alan.watson.f $

(define-library (oaxaca wfc)

  (export wfc-initialized?
          wfc-command
          wfc-wait
          wfc-idle?
          wfc-idle!
          wfc-a-vector
          wfc-set-a-vector!
          wfc-a-mean-vector
          wfc-a-sigma-vector
          wfc-da-mean-vector
          wfc-da-sigma-vector
          wfc-tm-v-vector
          wfc-dm-v-vector
          wfc-a-flat-vector
          wfc-set-a-flat-vector!
          wfc-flatten!
          wfc-zero!
          wfc-cycle)

  (import (scheme base)
          (scheme char)
          (scheme time))

  (import (prefix (oaxaca foreign) foreign:)
          (oaxaca log)
          (oaxaca thread))

  (begin

    (define (wfc-initialized?)
      (not (zero? (foreign:wfc-initialized))))

    (define (wfc-wait)
      (thread-wait-until! wfc-initialized?)
      (thread-wait-until! wfc-idle?)
      (values))

    (define (wfc-idle?)
      (eqv? #\I (foreign:wfc-command)))

    (define (wfc-idle!)
      (wfc-command! #\i #\I)
      (values))

    (define (wfc-fixed!)
      (wfc-command! #\f #\I)
      (values))

    (define (wfc-command)
      (foreign:wfc-command))

    (define (wfc-command! command acknowledgement)
      (unless (wfc-initialized?)
        (error "the wfc is not initialized."))
      (foreign:wfc-set-command! command)
      (thread-wait-until!
       (lambda ()
         (char=? (foreign:wfc-command) acknowledgement)))
      (values))

    (define na 7)

    (define (wfc-a-vector)
      (let ((modes (make-vector na 0.0)))
        (do ((i 0 (+ i 1)))
            ((= i na))
          (vector-set! modes i (foreign:wfc-a-vector-ref i)))
        modes))

    (define (wfc-set-a-vector! v)
      (unless (= (vector-length v) na)
        (error "incorrect number of mode amplitudes."))
      (do ((i 0 (+ i 1)))
          ((= i na))
        (foreign:wfc-a-vector-set! i (inexact (vector-ref v i))))
      (wfc-fixed!)
      (values))

    (define (wfc-a-mean-vector)
      (let ((modes (make-vector na 0.0)))
        (do ((i 0 (+ i 1)))
            ((= i na))
          (vector-set! modes i (foreign:wfc-a-mean-vector-ref i)))
        modes))

    (define (wfc-a-sigma-vector)
      (let ((modes (make-vector na 0.0)))
        (do ((i 0 (+ i 1)))
            ((= i na))
          (vector-set! modes i (foreign:wfc-a-sigma-vector-ref i)))
        modes))

    (define (wfc-da-mean-vector)
      (let ((modes (make-vector na 0.0)))
        (do ((i 0 (+ i 1)))
            ((= i na))
          (vector-set! modes i (foreign:wfc-da-mean-vector-ref i)))
        modes))

    (define (wfc-da-sigma-vector)
      (let ((modes (make-vector na 0.0)))
        (do ((i 0 (+ i 1)))
            ((= i na))
          (vector-set! modes i (foreign:wfc-da-sigma-vector-ref i)))
        modes))

    (define tm-nv 3)

    (define (wfc-tm-v-vector)
      (let ((v (make-vector tm-nv 0.0)))
        (do ((i 0 (+ i 1)))
            ((= i tm-nv))
          (vector-set! v i (foreign:wfc-tm-v-vector-ref i)))
        v))

    (define dm-nv 64)

    (define (wfc-dm-v-vector)
      (let ((v (make-vector dm-nv 0.0)))
        (do ((i 0 (+ i 1)))
            ((= i dm-nv))
          (vector-set! v i (foreign:wfc-dm-v-vector-ref i)))
        v))

    (define (wfc-a-flat-vector)
      (let ((modes (make-vector na 0.0)))
        (do ((i 0 (+ i 1)))
            ((= i na))
          (vector-set! modes i (foreign:wfc-a-flat-vector-ref i)))
        modes))

    (define (wfc-set-a-flat-vector! v)
      (unless (= (vector-length v) na)
        (error "incorrect number of mode amplitudes."))
      (do ((i 0 (+ i 1)))
          ((= i na))
        (foreign:wfc-a-flat-vector-set! i (inexact (vector-ref v i))))
      (values))

    (define (wfc-flatten!)
      (wfc-set-a-vector! (wfc-a-flat-vector)))

    (define a-zero-vector (make-vector na 0.0))

    (define (wfc-zero!)
      (wfc-set-a-vector! a-zero-vector))

    (define (wfc-cycle)
      (foreign:wfc-cycle))

    (define (benchmark! p)
      (let ((start-second (current-second))
            (start-cycle (wfc-cycle)))
        (p start-second start-cycle)
        (let ((end-second (current-second))
              (end-cycle (wfc-cycle)))
          (wfc-idle!)
          (/ (- end-cycle start-cycle) (- end-second start-second)))))))
